home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / 3A.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  58KB  |  1,827 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "3.h"
  11. #include "attr.h"
  12. #include "arithp.h"
  13. #include "miscp.h"
  14. #include "smiscp.h"
  15. #include "dclmapp.h"
  16. #include "nodesp.h"
  17. #include "errmsgp.h"
  18. #include "evalp.h"
  19. #include "setp.h"
  20. #include "chapp.h"
  21.  
  22. extern int *ADA_MIN_FIXED_MP, *ADA_MAX_FIXED_MP;
  23.  
  24. static void const_redecl(Node, Node, Node);
  25. static Symbol set_type_mark(Tuple, Node);
  26. static void build_type(Symbol, Node, Node);
  27. static void derived_type(Symbol, Node);
  28. static void build_derived_type(Symbol, Symbol, Node);
  29. static int in_unconstrained_natures(int);
  30. static int is_derived_type(Symbol);
  31. static void derive_subprograms(Symbol, Symbol);
  32. static void derive1_subprogram(Symbol, Symbol, Symbol, Symbol);
  33. static int hidden_derived(Symbol, Symbol);
  34. static Symbol find_neq(Symbol);
  35. static void new_enum_type(Symbol, Node);
  36. static void new_integer_type(Symbol, Node);
  37. static void new_floating_type(Symbol, Node);
  38. static void new_fixed_type(Symbol, Node);
  39. static Node real_bound(Node, Symbol);
  40. static Symbol constrain_scalar(Symbol, Node);
  41.  
  42. void obj_decl(Node node)                                     /*;obj_decl*/
  43. {
  44.     /* Process variable declaration. Verify that the type is a constrained one,
  45.      * or that default values exist for the discriminants of the type.
  46.      */
  47.  
  48.     Node id_list_node, type_indic_node, init_node, id_node, node1;
  49.     Symbol    type_mark, t_m, n;
  50.     int i;
  51.     Tuple    nam_list, id_nodes;
  52.     Fortup    ft1;
  53.  
  54.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : obj_decl");
  55.  
  56.     id_list_node  = N_AST1(node);
  57.     type_indic_node     = N_AST2(node);
  58.     init_node = N_AST3(node);
  59.  
  60.     id_nodes = N_LIST(id_list_node);
  61.     nam_list = tup_new(tup_size(id_nodes));
  62.     FORTUPI(id_node =(Node) , id_nodes, i,  ft1);
  63.         nam_list[i] = (char *) find_new(N_VAL(id_node));
  64.     ENDFORTUP(ft1);
  65.     type_mark = set_type_mark(nam_list, type_indic_node);
  66.  
  67.     current_node = type_indic_node;
  68.     check_fully_declared(type_mark);
  69.     adasem(init_node);
  70.  
  71.     /* If an initialization is provided, verify it has the specified type.  */
  72.     if (init_node != OPT_NODE)
  73.         t_m = check_init(type_indic_node, init_node);
  74.  
  75.     if (is_unconstrained(type_mark)) {
  76.         errmsg_nat("Unconstrained % in object declaration", type_mark,
  77.           "3.6.1, 3.7.2", type_indic_node);
  78.     }
  79.  
  80.     /*(forall n in nam_list) nature(n) := na_obj; end forall;*/
  81.     FORTUP(n=(Symbol), nam_list, ft1);
  82.         NATURE(n) = na_obj;
  83.     ENDFORTUP(ft1);
  84.     for (i = 1; i <= tup_size(id_nodes); i++) {
  85.         node1 = (Node) id_nodes[i];
  86.         N_UNQ(node1) = (Symbol) nam_list[i];
  87.     }
  88. }
  89.  
  90. void const_decl(Node node)                              /*;const_decl*/
  91. {
  92.     /* Process constant declarations. This may be a new declaration, or the
  93.      * full declaration of a deferred constant in the private part of a
  94.      * package. In this later case, recover the names of the constants, and
  95.      * update their definitions.
  96.      */
  97.  
  98.     Node    id_list_node, type_indic_node, init_node, id_node;
  99.     Tuple    id_nodes, id_list, nam_list;
  100.     Symbol    type_mark, t_m, n;
  101.     char    *id;
  102.     int    i, exists;
  103.     Fortup    ft1;
  104.     Symbol    s;
  105.  
  106.     if (cdebug2 > 3)  TO_ERRFILE("AT PROC : const_decl");
  107.  
  108.     id_list_node = N_AST1(node);
  109.     type_indic_node = N_AST2(node);
  110.     init_node = N_AST3(node);
  111.  
  112.     id_nodes = N_LIST(id_list_node);
  113.     id_list = tup_new(tup_size(id_nodes));
  114.     FORTUPI(id_node =(Node), id_nodes, i, ft1);
  115.         id_list[i] = N_VAL(id_node);
  116.     ENDFORTUP(ft1);
  117.     adasem(init_node);
  118.  
  119.     if (NATURE(scope_name) == na_private_part) {
  120.         exists = FALSE;
  121.         FORTUP(id=, id_list, ft1);
  122.             if (dcl_get(DECLARED(scope_name), id) != (Symbol)0) {
  123.                 exists = TRUE;
  124.                 break;
  125.             }
  126.         ENDFORTUP(ft1);
  127.         if (exists ){
  128.             /* It must be a deferred constant. */
  129.             const_redecl(id_list_node, type_indic_node, init_node);
  130.             return;
  131.             /* Otherwise it is a fully private constant. */
  132.         }
  133.     }
  134.  
  135.     nam_list = tup_new(tup_size(id_list));
  136.     FORTUPI(id =, id_list, i, ft1);
  137.         nam_list[i] = (char *) find_new(id);
  138.     ENDFORTUP(ft1);
  139.  
  140.     type_mark = set_type_mark(nam_list, type_indic_node);
  141.  
  142.     if (init_node == OPT_NODE) {
  143.         /* Deferred constant.*/
  144.         s = TYPE_OF(base_type(type_mark));
  145.         if (s != symbol_private && s != symbol_limited_private) {
  146.             errmsg("Missing initialization in constant declaration", "3.2",
  147.               node);
  148.         }
  149.         else if (SCOPE_OF(type_mark) != scope_name) {
  150.             errmsg("Wrong scope for type of deferred constant", "7.4",
  151.               type_indic_node);
  152.         }
  153.         else if ( (NATURE(scope_name) != na_package_spec)
  154.           && (NATURE(scope_name) != na_generic_package_spec) ) {
  155.             errmsg("Invalid context for deferred constant", "3.2, 7.4", node);
  156.         }
  157.         else if (is_generic_type(type_mark)
  158.           || is_generic_type(base_type(type_mark))) { 
  159.             errmsg("constants of a generic type cannot be deferred", "12.1.2",
  160.               node);
  161.         }
  162.         else if (is_anonymous(type_mark)) {
  163.             errmsg("a deferred constant must be defined with a type mark",
  164.               "7.4.3", node);
  165.         }
  166.     }
  167.     else {
  168.         t_m = check_init(type_indic_node, init_node);
  169.  
  170.         if (t_m != type_mark) {
  171.             /* t_m is an anonymous type created from the bounds of init value*/
  172.             FORTUP(n = (Symbol), nam_list, ft1);
  173.                 TYPE_OF(n) = t_m;
  174.             ENDFORTUP(ft1);
  175.         }
  176.     }
  177.  
  178.     FORTUP(n =(Symbol), nam_list, ft1);
  179.         NATURE(n) = na_constant;
  180.         SIGNATURE(n) = (Tuple) init_node;
  181.     ENDFORTUP(ft1);
  182.     for (i = 1; i <= tup_size(id_nodes); i++) {
  183.         Node tmp = (Node) id_nodes[i];
  184.         N_UNQ(tmp) = (Symbol) nam_list[i];
  185.     }
  186. }
  187.  
  188. static void const_redecl(Node id_list_node, Node type_indic_node,
  189.   Node init_node)                                             /*;const_redecl*/
  190. {
  191.     /* Process the full declaration of deferred constants. at least one id
  192.      * in  id_list is know to have been declared in the visible part of the
  193.      * current scope.
  194.      */
  195.  
  196.     Symbol    u_n, t_m, type_mark;
  197.     Symbol    ut;
  198.     Node    id_node, tmp;
  199.     Tuple    id_nodes, nam_list, id_list;
  200.     char    *id;
  201.     int    i;
  202.     Fortup    ft1;
  203.  
  204.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : const_redecl");
  205.  
  206.     id_nodes = N_LIST(id_list_node);
  207.     id_list = tup_new(tup_size(id_nodes));
  208.     FORTUPI(id_node =(Node), id_nodes, i, ft1);
  209.         id_list[i]  = N_VAL(id_node);
  210.     ENDFORTUP(ft1);
  211.     nam_list = tup_new(0);
  212.     /* The type indication must be a subtype indication .*/
  213.  
  214.     if (N_KIND(type_indic_node) == as_subtype_indic) {
  215.         adasem(type_indic_node);
  216.         type_mark = promote_subtype(make_subtype(type_indic_node));
  217.     }
  218.     else
  219.         /* An anonymous array is syntactically possible, but incorrect. */
  220.         type_mark = anonymous_array(type_indic_node);
  221.  
  222.     N_UNQ(type_indic_node) = type_mark;
  223.  
  224.     FORTUP(id =, id_list, ft1);
  225.         u_n = dcl_get(DECLARED(scope_name), id);
  226.         if (u_n == (Symbol)0) {
  227.             errmsg_str("% is not a deferred constant", id, "3.2, 7.4",
  228.               id_list_node);
  229.             nam_list = tup_with(nam_list, (char *)symbol_any);
  230.             continue;
  231.         }
  232.         else if((NATURE(u_n) != na_constant)
  233.           || ((Node) SIGNATURE(u_n) != OPT_NODE)) {
  234.             errmsg_str("Invalid redeclaration of %", id, "8.3", id_list_node);
  235.             nam_list = tup_with(nam_list, (char *)symbol_any);
  236.             continue;
  237.         }
  238.         else if ( ((ut = TYPE_OF(u_n)) != type_mark)
  239.           /* They may still be the same subtype of some private type.*/
  240.           && (TYPE_OF(ut) != TYPE_OF(type_mark))
  241.           || (SIGNATURE(ut) != SIGNATURE(type_mark)))
  242.         {
  243.             errmsg_str("incorrect type in redeclaration of %", id,
  244.               "7.4, 7.4.1", id_list_node);
  245.             nam_list = tup_with(nam_list, (char *)symbol_any);
  246.         }
  247.         else if (init_node == OPT_NODE) {    /* No initiali(zation ? */
  248.             errmsg_str("Missing initialization in redeclaration of %", id,
  249.               "7.4", id_list_node);
  250.             nam_list = tup_with(nam_list, (char *)symbol_any);
  251.         }
  252.         else {
  253.             TO_XREF(u_n);
  254.             nam_list = tup_with(nam_list, (char *)  u_n);
  255.         }
  256.     ENDFORTUP(ft1);
  257.  
  258.     for (i = 1; i <= tup_size(id_nodes); i++) {
  259.         tmp = (Node) id_nodes[i];
  260.         N_UNQ(tmp ) = (Symbol) nam_list[i];
  261.     }
  262.  
  263.     if (init_node != OPT_NODE ) {
  264.         t_m = check_init(type_indic_node, init_node);
  265.         FORTUP(u_n=(Symbol), nam_list, ft1);
  266.             SIGNATURE(u_n) = (Tuple) init_node;
  267.         ENDFORTUP(ft1);
  268.     }
  269. }
  270.  
  271. static Symbol set_type_mark(Tuple nam_list, Node type_indic_node)
  272.                                                             /*;set_type_mark*/
  273. {
  274.     /* Set the symbol table entry for object or constant declarations.
  275.      * The type indication is a subtype indication or an array definition. In
  276.      * the later case, an anonymous array type must be created for each item
  277.      * in the name list. For the interpreter, any